(in-package :cl-gdbm)

;; GDBM objects
;;;;;;;;;;;;;;;

(defclass gdbm-database ()
  ((db-pointer :initarg :db-pointer :reader db-pointer
	       :documentation "A pointer to the database struct")
   (filename :initarg :filename :reader filename))
  (:documentation "A GDBM database. You should never create one of
these directly; use OPEN-GDBM instead."))

(defmethod print-object ((object gdbm-database) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (princ (filename object) stream)))

;; Errors
;;;;;;;;;

(define-condition cannot-write-error (error)
  ((db :initarg :db :reader cannot-write-error-db))
  (:report (lambda (condition stream)
	     (format stream "Cannot write to GDBM database ~S"
		     (cannot-write-error-db condition)))))

(define-condition key-not-found (warning)
  ((db :initarg :db :reader key-not-found-db)
   (key :initarg :key :reader key-not-found-key))
  (:report (lambda (condition stream)
	     (format stream "Key ~S not found in GDBM database ~S"
		     (key-not-found-key condition)
		     (key-not-found-db condition)))))

(define-condition cannot-set-option-error (error)
  ((db :initarg :db :reader cannot-set-option-db))
  (:report (lambda (condition stream)
	     (format stream "Cannot set option on GDBM database ~S"
		     (cannot-set-option-db condition)))))

;; Serialization/deserialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun repr (x)
  "Convert a Lisp object to a serialized string"
  (with-output-to-string (string)
    (let ((*print-readably* t))
      (prin1 x string))))

(defun de-repr (x)
  "Convert a serialized string to a Lisp object"
  (let ((*read-eval* nil))
    (values (read-from-string x nil nil))))

;; Basic operations
;;;;;;;;;;;;;;;;;;;

(defun open-gdbm (filename &key (mode :write) (blocksize 1024)
		  (permissions 0666) (fastp t))
  "Open a GDBM database, returning it. MODE is either :read or :write,
BLOCKSIZE is an integer specifying the GDBM block size in bytes,
PERMISSIONS is a Unix permissions setting, by defauly 0666. If FASTP
is true, the database will be opened in fast mode, and changes will
not be written until the database in explicity synchronized."
  (declare (unsigned-byte blocksize permissions))
  (let* ((mode-decoded (let ((major-mode (ecase mode
					   (:read GDBM_READER)
					   (:write GDBM_WRCREAT))))
			 (if fastp
			     (logior major-mode GDBM_FAST)
			     (logior major-mode GDBM_SYNC))))
	 (file (with-cstring (filename-cstring (namestring filename))
		 (gdbm-open-file filename-cstring blocksize
				 mode-decoded permissions))))
    (make-instance 'gdbm-database
		   :db-pointer file
		   :filename filename)))

(defmethod store ((db gdbm-database) key data)
  "Set KEY=DATA in DB"
  (with-cstring (c-key (repr key))
    (with-cstring (c-data (repr data))
      (ecase (gdbm-store (db-pointer db) c-key c-data GDBM_REPLACE)
	(0 data)
	(-1 (error 'cannot-write-error :db db))))))

(defmethod fetch ((db gdbm-database) key)
  "Return DB's association for KEY, or NIL if there isn't one"
  (with-cstring (c-key (repr key))
    (aif (let ((result (gdbm-fetch (db-pointer db) c-key)))
	   (prog1 (convert-from-foreign-string result)
	     (free-foreign-object result)))
	 (de-repr it)
	 (restart-case (warn 'key-not-found :db db :key key)
	   (continue ()
	     :report "Return NIL"
	     nil)
	   (use-value (value)
	     :report "Specify a value to use this time."
	     value)
	   (store-value (value)
	     :report "Specify a value to store and use in the future."
	     (store db key value))))))

(defmethod close-db ((db gdbm-database))
  "Close a database"
  (gdbm-close-file (db-pointer db)))

(defmethod reorganize-db ((db gdbm-database))
  "Reorganize a database, shrinking it if you've had a lot of
deletions. This should be used very seldom, since it's inefficient."
  (gdbm-reorganize (db-pointer db)))

(defmethod sync-db ((db gdbm-database))
  "Synchronize the database with its storage on disk. You only need to
worry about this if you're using a database in fast mode."
  (gdbm-sync (db-pointer db)))

(defmethod delete-key ((db gdbm-database) key)
  "Delete KEY from the database DB"
  (case (gdbm-delete (db-pointer db) (repr key))
    (-1 (warn 'key-not-found :db db :key key))))

(defmethod delete-keys ((db gdbm-database) &key (reorganize-p t))
  "Delete all the keys in DB, optionally reorganizing the database
afterwards, which should be fast."
  (mapc #'(lambda (key) (delete-key db key))
	  (keys-of db))
  (when reorganize-p
    (reorganize-db db)))

(defmethod key-exists-p ((db gdbm-database) key)
  "Does KEY exist in the database DB?"
  (ecase (gdbm-exists-p (db-pointer db) (repr key))
    (0 nil)
    (1 t)))

;; Options
;;;;;;;;;;

(defmethod set-syncmode ((db gdbm-database) state)
  (ecase (gdbm-set-syncmode (db-pointer db) (if state 1 0))
    (0 nil)
    (-1 (restart-case (error 'cannot-set-option-error :db db)
	  (continue ()
	    :report "Return NIL"
	    nil)))))

(defmethod set-cachesize ((db gdbm-database) state)
  (ecase (gdbm-set-cachesize (db-pointer db) state)
    (0 nil)
    (-1 (restart-case (error 'cannot-set-option-error :db db)
	  (continue ()
	    :report "Return NIL"
	    nil)))))

;; Sequential access
;;;;;;;;;;;;;;;;;;;;

(defmethod first-key ((db gdbm-database))
  "Returns a key in DB for sequential traversal, or returns NIL if
there are no keys."
  (awhen (let ((result (gdbm-first-key (db-pointer db))))
	   (prog1 (convert-from-foreign-string result)
	     (free-foreign-object result)))
    (de-repr it)))

(defmethod next-key ((db gdbm-database) key)
  "Returns the key after KEY in sequential traversal of DB"
  (with-cstring (c-key (repr key))
    (awhen (let ((result (gdbm-next-key (db-pointer db) c-key)))
	     (prog1 (convert-from-foreign-string result)
	       (free-foreign-object result)))
      (de-repr it))))

(defmacro dokeys ((name db &optional result-form) &body body)
  (once-only (db)
    `(do ((,name (first-key ,db) (next-key ,db ,name)))
	 ((null ,name) ,result-form)
       ,@body)))

(defmethod keys-of ((db gdbm-database))
  "Return the keys of a GDBM database"
  (collecting (dokeys (key db)
		(collect key))))

(defmethod db->alist ((db gdbm-database))
  "Convert a GDBM database to an alist"
  (collecting
   (dokeys (key db)
     (collect (cons key (getkey db key))))))

(defmethod alist->db ((db gdbm-database) alist &key delete-others)
  "Convert an alist to a GDBM database. If DELETE-OTHERS is true,
other keys in the database will be deleted."
  (when delete-others
    (delete-keys db))
  (loop for (key . value) in alist
	do (setf (getkey db key) value)))

;; SETF interface
;;;;;;;;;;;;;;;;;

(defun getkey (db key)
  "Return DB's association for KEY, or NIL if there isn't one"
  (fetch db key))

(defun (setf getkey) (data db key)
  (store db key data))

;; Opening macro
;;;;;;;;;;;;;;;;

(defmacro with-open-db ((name filename &key
			      (mode :write) (blocksize 1024)
			      (permissions 0666) (fastp t))
			&body body)
  "Open a GDBM database, bind it to NAME, and execute BODY. Make sure
the database gets closed cleanly."
  `(let ((,name (open-gdbm ,filename
			   :mode ,mode
			   :blocksize ,blocksize
			   :permissions ,permissions
			   :fastp ,fastp)))
    (unwind-protect (progn ,@body)
      (close-db ,name))))